home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
oobpls10.zip
/
OLGIF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-11-06
|
14KB
|
474 lines
{$F+,O+,R-,S-,V-,A+}
unit OLGIF; {online GIF decoder using OOBPLUS services}
{$I OPDEFINE.INC}
{.$DEFINE Debug}
interface
uses
DOS,
OpRoot,
OpInline,
OpCrt,
OpMouse,
OpDrag,
OpFrame,
OpWindow,
ApMisc,
ApTimer,
ApPort,
OOCom,
OOBPlus,
DeGIF,
GIFVideo;
const
UnitVers = '1.0d';
UnitDate = '05-Jun-91';
TmpGifName = '$$TEMP$$.GIF';
const
GifCapOK : Boolean = True;
GifCapName : PathStr = '';
function DisplayGIFOnline(APP : AbstractPortPtr;
WaitForKey : Boolean) : Boolean;
{-decodes BPlus-encapsulated GIF image data stream}
implementation
const
BuffSize = 2048; {size of our local buffer}
YInc : Array[1..6] of Byte = (8,8,4,2,1,0); {used for interlaced image}
YLin : Array[1..6] of Byte = (0,4,2,1,0,0); {decoding/management}
YInt : Array[1..6] of Byte = (7,3,1,0,0,0);
type
BuffType = Array[1..$FFF1] of Byte; {local decode buffer types}
BuffPtr = ^BuffType;
var
GBP : BPProtoGIFPtr; {our GIF BPlus handler}
var
GIFBuff : BuffPtr; {our decode I/O buffer}
GRec : JumpRecord; {used for error handling}
Pass : Byte; {interlace pass counter}
Intrlace : Boolean; {true if an interlaced image}
Image : Word; {counter for images in this stream}
Done : Boolean; {true when complete}
GIFCap : Boolean; {true if capturing stream to file}
InBPlus : Boolean; {true once B+ processing active}
BufIdx : Word; {current index in the I/O buffer}
Count : Word; {bytes currently in I/O buffer}
GF : File; {file to write stream to}
EOFin : Boolean; {true if we've seen EOF mark in stream}
SW : StackWindowPtr; {used to save underlying screen}
MouseB : Boolean;
{-------------------------------}
{ High-level online GIF decoder }
{-------------------------------}
procedure RingBell;
{-noisemaker}
begin
Sound(440);
Delay(100);
NoSound;
end;
procedure Purge(GBP : BPProtoGIFPtr);
{-purge pending <DLE> after abort}
var
E : EventTimer;
I : Integer;
C : Char;
begin
with GBP^, APort^ do begin
for I := 1 to 3 do begin
NewTimerSecs(E,5);
while not CharReady do
if TimerExpired(E) then exit;
PeekChar(C,1);
if C <> cDLE then
exit
else
if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then ;
end;
end;
end;
procedure EndIt(GBP : BPProtoGIFPtr; B : Boolean);
{-abort processing procedure}
begin
if InBPlus then with GBP^ do begin
if NOT Aborting then
SendFailure('AAborted by user');
Purge(GBP);
end;
if GraphOn then
SetTextMode;
if B then begin
RingBell;
RingBell;
end;
LongJump(GRec,1);
end;
function MyGetByte : Byte;
{-get next byte in stream}
var B : Boolean;
begin
with GBP^ do begin
{if we've exhausted the last block, read a new one}
if BufIdx > Count then begin
if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then begin
{$IFDEF Debug}
if NOT GraphOn then
WriteLn('Packet size=',Count);
{$ENDIF}
if GIFCap then begin {write the file}
BlockWrite(GF,GIFBuff^,Count);
if IOResult <> 0 then begin {whoops! clean house}
Close(GF); if IOResult = 0 then ;
GIFCap := False; {and set our flag}
end;
end;
bpSendACK; {acknowledge the packet}
BufIdx := 1; {reset the buffer index}
end
else begin {failed packet read, abort...}
{$IFDEF Debug}
if NOT GraphOn then begin
WriteLn('Unable to read B+ data packet - Aborting...');
Delay(2000);
end;
{$ENDIF}
EndIt(GBP,True); {and leave}
end;
end;
end;
MyGetByte := GIFBuff^[BufIdx]; {get the byte}
Inc(BufIdx); {keep counter straight}
end;
procedure MyPutLine;
{-plot the raster line of pixels to hardware, handle interlacing}
var I : Integer;
begin
if YCord <= Raster then {don't wrap back to top of screen!}
PlotLine(YCord);
Inc(YCord,YInc[Pass]); {select next line to plot per interlace}
if YCord >= BotEdge then begin
if Pass < 5 then Inc(Pass); {reset to top of image per interlace}
YCord := YLin[Pass] + TopEdge;
end;
end;
procedure MyPutLineDbl;
{-our decoder's PutLine proc. This method accomodates interlaced GIFs}
var I : Integer;
begin
if YCord <= Raster then {don't wrap back to top of screen!}
PlotLine(YCord);
Inc(YCord,YInc[Pass] shl 1);
if YCord >= BotEdge then begin
if Pass < 5 then Inc(Pass);
YCord := (YLin[Pass] shl 1) + TopEdge;
end;
end;
procedure AdjustVars;
{-match decode/display vars to image sizes}
var I : Byte;
begin
Inc(Image);
Pass := 5;
IntrLace := FALSE;
LeftEdge := ImageLeft;
TopEdge := ImageTop;
if (ScrWidth = 300) and (ScrHeight = 200) then begin
Inc(LeftEdge, 10);
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end
else if (ScrWidth = 378) and (ScrHeight = 240) then begin
if (DoDbl) then begin
RightEdge := 700;
BotEdge := 480;
end
else begin
Inc(LeftEdge, 131);
Inc(TopEdge, (Raster shr 1) - 120);
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end;
end
else begin
if ImageWidth < Pixels then
Inc(LeftEdge, (Pixels shr 1) - (ImageWidth shr 1));
if ImageHeight < Raster then
Inc(TopEdge, (Raster shr 1) - (ImageHeight shr 1));
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end;
YCord := TopEdge;
if Maps[Local].Interlaced then
Pass := 1;
end;
function OnLineGIFSig : Boolean;
{-init B+ proto for GIF and get signature. The scenario is:
(host->remote) <ENQ>
(host<-remote) <DLE>++<DLE>0
(host->remote) BPlus "+" packet
(host<-remote) process "+" packet, send ACK packet
(host->remote) first "N" packet containing actual GIF stream...
For hysterical, uh, historical reasons we wait up to 6 chars to receive
the handshake for the protocol. (Actually, until recently there were a few
areas of CIS, such as TREND, that did not provide B+ encapsulation and just
sent the stream; we had to be able to get either a handshake or the GIF
signature, and if no B+ then abandon proto processing and get the stream
"raw".) }
var C : Char;
S : String[5];
I,X : Integer;
begin
{set things up}
OnlineGIFSig := False;
I := 0;
GIFSig := '';
{$IFDEF Debug}
WriteLn('Getting GIF signature...');
{$ENDIF}
{loop getting bytes from the port and processing}
repeat
Inc(I);
C := #0;
AsyncStatus := ecOK;
if I = 1 then X := 30 else X := 10; {30 secs for first byte, else 10}
GBP^.APort^.GetCharTimeOut(C,Secs2Tics(X));
if AsyncStatus <> ecOK then {read failed, drop out}
Exit;
case C of
#5 : {<ENQ> seen, respond}
begin
GBP^.bpHandleENQ;
Dec(I); {dec counter to allow more chars}
end;
#16: {<DLE> starting "+" packet seen, handle it}
begin
if GBP^.bpDLESeen then begin {"+" packet OK, we outa here:}
OnlineGIFSig := True;
InBPlus := True;
GetGIFSig; {force first packet read, get}
exit; {6-byte signature for check}
end
else
exit; {"+" packet failed, get out}
end;
else
GIFSig := GIFSig + C; {attempt build of "raw" signature}
end;
until I >= 6;
OnlineGIFSig := True;
end;
function PortQuiese(AP : AbstractPortPtr; MinWait,MaxWait : Word) : Boolean;
{-wait at least MinWait secs for port "quiet", up to MaxWait secs}
var
E1,E2 : EventTimer;
Tmp : BPtr;
begin
PortQuiese := True;
with AP^.Pr^ do begin
NewTimer(E1,Secs2Tics(MaxWait));
repeat
Tmp := InHead;
NewTimer(E2,Secs2Tics(MinWait));
while not TimerExpired(E2) do ;
if Tmp = InHead then exit;
until TimerExpired(E1);
PortQuiese := False;
end;
end;
function DecodeGIF(GBP : BPProtoGIFPtr) : Integer;
{-GIF stream decode logic}
var I : Integer;
BlockType : Char;
begin
{init vars}
Done := False;
Image := 0;
CurMap := Global;
DecodeGIF := -9;
{get signature (inits BPlus protocol)}
if NOT OnlineGIFSig then
EndIt(GBP,False);
{verify signature. To accomodate future versions, we accept anything}
{with the first 3 chars "GIF" and the next 3 as 2 digits and a lower }
{case char. }
if (Pos('GIF',GIFSig) <> 1) or
(NOT(GIFSig[4] in ['0'..'9'])) or
(NOT(GIFSig[5] in ['0'..'9'])) or
(NOT(GIFSig[6] in ['a'..'z'])) then
EndIt(GBP,True);
{get the hardware specifics, match a video mode as close as we can}
GetScrDes(Maps[Global]);
SelMode := SelectMode(ScrWidth,ScrHeight);
if SelMode = 0 then EndIt(GBP,True);
{if we have a global map, process it}
if Maps[Global].MapExists then
DoMapping
else
SetDefMap;
{kick into graphics mode then juggle the palette to match our map}
with GBP^, APort^ do begin
PutChar(cXoff); {tell host to stop transmitting}
if PortQuiese(APort,1,6) then ; {wait for port to quiese}
HideMousePrim(MouseB); {hide the mouse}
SW^.Draw; {save the screen}
if (CurrentDisplay in [EGA,VGA]) and
(ScrWidth = 378) and
(ScrHeight = 240) then
if (DoDbl) then
PutLine := MyPutLineDbl;
SetGraphicsMode(SelMode); {set graphics mode}
AdjustPalette(SelMode); {and juggle the palette}
PutChar(cXon); {tell host it can start again}
end;
{loop reading blocks and processing...}
while NOT Done do begin
BlockType := Chr(GetByte); {get blocktype char}
case BlockType of
',': begin {"Local descriptor"/image, process...}
GetImageDescription(Maps[Local]);
AdjustVars;
if Maps[Local].MapExists then begin
{juggle palette again}
CurMap := Local;
DoMapping;
AdjustPalette(SelMode);
end;
{decode the image data and display}
I := ExpandGIF;
if I <> 0 then begin
DecodeGIF := I; {decoder error (LZW couldn't decomp)}
EndIt(GBP,True);
end;
CurMap := Global; {reselect global map for possible next image}
end;
'!': SkipExtendBlock; {"Extension" block, we discard}
';': begin {Terminator seen, clean up and go home}
Done := True;
{a "TC" packet will be pending, get it}
with GBP^ do while NOT EOFin do
if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then
bpSendACK;
InBPlus := False;
{if the capture file is open, close it}
if GIFCap then begin
Close(GF); if IOResult = 0 then ;
GifCapOK := True;
end;
DecodeGIF := 0;
exit;
end;
end;
end;
end;
function DisplayGIFOnLine(APP : AbstractPortPtr;
WaitForKey : Boolean): Boolean;
{-our high-level online decoder}
label
Break;
var L : LongInt;
W : Word;
C : Char Absolute W;
N : Integer;
B : Boolean;
begin
DisplayGIFOnline := False;
InBPlus := False;
MouseB := True;
GifCapOK := False;
GBP := nil;
if NOT GetMemCheck(GIFBuff,BuffSize) then
exit;
New(SW, Init(1, 1, ScreenWidth, ScreenHeight));
if SW = nil then begin
FreeMemCheck(GIFBuff, BuffSize);
exit;
end;
{init protocol object}
New(GBP,Init(APP));
if GBP = NIL then
goto Break;
{point to our get/put routines}
GetByte := MyGetByte;
PutLine := MyPutLine;
{init error handler}
N := SetJump(GRec);
if N <> 0 then
goto Break;
{set buffer vars to force initial read}
Count := 0;
BufIdx := 999;
{init capture file}
Assign(GF, TmpGifName);
Rewrite(GF, 1);
GIFCap := (IOResult = 0);
{process...}
N := DecodeGIF(GBP);
{if successful, wait for keypress}
if N = 0 then begin
RingBell;
DisplayGIFOnline := GIFCap;
{wait for <CR> or <ESC> before clearing}
if WaitForKey then repeat
W := ReadKeyOrButton;
until (C = #13) or (C = #27) or (Hi(W) in [$ED, $EE, $EF]);
ClearMouseEvents;
end;
SetTextMode;
Break:
if GBP <> nil then
Dispose(GBP, Done);
if SW^.IsActive then
SW^.EraseHidden;
MouseGoToXY(ScreenWidth shr 1, ScreenHeight shr 1);
ShowMousePrim(MouseB);
Dispose(SW, Done);
FreeMemCheck(GIFBuff, BuffSize);
end;
end.